home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clcs / restart.lisp < prev    next >
Lisp/Scheme  |  1990-12-06  |  7KB  |  210 lines
  1. ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
  2.  
  3. (IN-PACKAGE "CONDITIONS")
  4.  
  5. ;;; Unique Ids
  6.  
  7. (DEFVAR *UNIQUE-ID-TABLE* (MAKE-HASH-TABLE))
  8. (DEFVAR *UNIQUE-ID-COUNT* -1)
  9.  
  10. (DEFUN UNIQUE-ID (OBJ)
  11.   "Generates a unique integer ID for its argument."
  12.   (OR (GETHASH OBJ *UNIQUE-ID-TABLE*)
  13.       (SETF (GETHASH OBJ *UNIQUE-ID-TABLE*) (INCF *UNIQUE-ID-COUNT*))))
  14.  
  15. ;;; Miscellaneous Utilities
  16.  
  17. (EVAL-WHEN (EVAL COMPILE LOAD)
  18.  
  19. (DEFUN PARSE-KEYWORD-PAIRS (LIST KEYS)
  20.   (DO ((L LIST (CDDR L))
  21.        (K '() (LIST* (CADR L) (CAR L) K)))
  22.       ((OR (NULL L) (NOT (MEMBER (CAR L) KEYS)))
  23.        (VALUES (NREVERSE K) L))))
  24.  
  25. (DEFMACRO WITH-KEYWORD-PAIRS ((NAMES EXPRESSION &OPTIONAL KEYWORDS-VAR) &BODY FORMS)
  26.   (LET ((TEMP (MEMBER '&REST NAMES)))
  27.     (UNLESS (= (LENGTH TEMP) 2) (ERROR "&REST keyword is ~:[missing~;misplaced~]." TEMP))
  28.     (LET ((KEY-VARS (LDIFF NAMES TEMP))
  29.           (KEY-VAR (OR KEYWORDS-VAR (GENSYM)))
  30.           (REST-VAR (CADR TEMP)))
  31.       (LET ((KEYWORDS (MAPCAR #'(LAMBDA (X) (INTERN (STRING X) (FIND-PACKAGE "KEYWORD")))
  32.                   KEY-VARS)))
  33.         `(MULTIPLE-VALUE-BIND (,KEY-VAR ,REST-VAR)
  34.              (PARSE-KEYWORD-PAIRS ,EXPRESSION ',KEYWORDS)
  35.            (LET ,(MAPCAR #'(LAMBDA (VAR KEYWORD) `(,VAR (GETF ,KEY-VAR ,KEYWORD)))
  36.                                  KEY-VARS KEYWORDS)
  37.              ,@FORMS))))))
  38.  
  39. );NEHW-LAVE
  40.  
  41. ;;; Restarts
  42.  
  43. (DEFVAR *RESTART-CLUSTERS* '())
  44.  
  45. (DEFUN COMPUTE-RESTARTS ()
  46.   #+kcl (nconc (mapcan #'copy-list *RESTART-CLUSTERS*) (kcl-top-restarts))
  47.   #-kcl (mapcan #'copy-list *RESTART-CLUSTERS*))
  48.  
  49. (DEFUN RESTART-PRINT (RESTART STREAM DEPTH)
  50.   (DECLARE (IGNORE DEPTH))
  51.   (IF *PRINT-ESCAPE*
  52.       (FORMAT STREAM "#<~S.~D>" (TYPE-OF RESTART) (UNIQUE-ID RESTART))
  53.       (RESTART-REPORT RESTART STREAM)))
  54.  
  55. (DEFSTRUCT (RESTART (:PRINT-FUNCTION RESTART-PRINT))
  56.   NAME
  57.   FUNCTION
  58.   REPORT-FUNCTION
  59.   INTERACTIVE-FUNCTION)
  60.  
  61. #+kcl
  62. (progn
  63. (defvar *kcl-top-restarts* nil)
  64.  
  65. (defun make-kcl-top-restart (quit-tag)
  66.   (make-restart :name 'abort
  67.         :function #'(lambda () (throw (car (list quit-tag)) quit-tag))
  68.         :report-function 
  69.         #'(lambda (stream) 
  70.             (let ((b-l (if (eq quit-tag si::*quit-tag*)
  71.                    si::*break-level*
  72.                    (car (or (find quit-tag si::*quit-tags*
  73.                           :key #'cdr)
  74.                         '(:not-found))))))
  75.               (cond ((eq b-l :not-found)
  76.                  (format stream "Return to ? level."))
  77.                 ((null b-l)
  78.                  (format stream "Return to top level."))
  79.                 (t
  80.                  (format stream "Return to break level ~D."
  81.                      (length b-l))))))
  82.         :interactive-function nil))
  83.  
  84. (defun find-kcl-top-restart (quit-tag)
  85.   (cdr (or (assoc quit-tag *kcl-top-restarts*)
  86.        (car (push (cons quit-tag (make-kcl-top-restart quit-tag))
  87.               *kcl-top-restarts*)))))
  88.  
  89. (defun kcl-top-restarts ()
  90.   (let* ((old-tags (mapcan #'(lambda (e) (when (cdr e) (list (cdr e))))
  91.                si::*quit-tags*))
  92.      (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags))
  93.      (restarts (mapcar #'find-kcl-top-restart tags)))
  94.     (setq *kcl-top-restarts* (mapcar #'cons tags restarts))
  95.     restarts))
  96. )  
  97.  
  98. (DEFUN RESTART-REPORT (RESTART STREAM)
  99.   (FUNCALL (OR (RESTART-REPORT-FUNCTION RESTART)
  100.                (LET ((NAME (RESTART-NAME RESTART)))
  101.          #'(LAMBDA (STREAM)
  102.              (IF NAME (FORMAT STREAM "~S" NAME)
  103.                   (FORMAT STREAM "~S" RESTART)))))
  104.            STREAM))
  105.  
  106. (DEFMACRO RESTART-BIND (BINDINGS &BODY FORMS)
  107.   `(LET ((*RESTART-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (BINDING)
  108.                                `(MAKE-RESTART
  109.                               :NAME     ',(CAR BINDING)
  110.                               :FUNCTION ,(CADR BINDING)
  111.                               ,@(CDDR BINDING)))
  112.                            BINDINGS))
  113.                    *RESTART-CLUSTERS*)))
  114.      ,@FORMS))
  115.  
  116. (DEFUN FIND-RESTART (NAME)
  117.   (DOLIST (RESTART-CLUSTER *RESTART-CLUSTERS*)
  118.     (DOLIST (RESTART RESTART-CLUSTER)
  119.       (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME))
  120.     (RETURN-FROM FIND-RESTART RESTART))))
  121.   #+kcl 
  122.   (let ((RESTART-CLUSTER (kcl-top-restarts)))
  123.     (DOLIST (RESTART RESTART-CLUSTER)
  124.       (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME))
  125.     (RETURN-FROM FIND-RESTART RESTART)))))
  126.   
  127. (DEFUN INVOKE-RESTART (RESTART &REST VALUES)
  128.   (LET ((REAL-RESTART (OR (FIND-RESTART RESTART)
  129.               (ERROR "Restart ~S is not active." RESTART))))
  130.     (APPLY (RESTART-FUNCTION REAL-RESTART) VALUES)))
  131.  
  132. (DEFUN INVOKE-RESTART-INTERACTIVELY (RESTART)
  133.   (LET ((REAL-RESTART (OR (FIND-RESTART RESTART)
  134.               (ERROR "Restart ~S is not active." RESTART))))
  135.     (APPLY (RESTART-FUNCTION REAL-RESTART)
  136.        (LET ((INTERACTIVE-FUNCTION
  137.            (RESTART-INTERACTIVE-FUNCTION REAL-RESTART)))
  138.          (IF INTERACTIVE-FUNCTION
  139.          (FUNCALL INTERACTIVE-FUNCTION)
  140.          '())))))
  141.  
  142. (DEFMACRO RESTART-CASE (EXPRESSION &BODY CLAUSES)
  143.   (FLET ((TRANSFORM-KEYWORDS (&KEY REPORT INTERACTIVE)
  144.        (LET ((RESULT '()))
  145.          (WHEN REPORT
  146.            (SETQ RESULT (LIST* (IF (STRINGP REPORT)
  147.                        `#'(LAMBDA (STREAM)
  148.                         (WRITE-STRING ,REPORT STREAM))
  149.                        `#',REPORT)
  150.                    :REPORT-FUNCTION
  151.                    RESULT)))
  152.          (WHEN INTERACTIVE
  153.            (SETQ RESULT (LIST* `#',INTERACTIVE
  154.                    :INTERACTIVE-FUNCTION
  155.                    RESULT)))
  156.          (NREVERSE RESULT))))
  157.     (LET ((BLOCK-TAG (GENSYM))
  158.       (TEMP-VAR  (GENSYM))
  159.       (DATA
  160.         (MAPCAR #'(LAMBDA (CLAUSE)
  161.             (WITH-KEYWORD-PAIRS ((REPORT INTERACTIVE &REST FORMS)
  162.                          (CDDR CLAUSE))
  163.               (LIST (CAR CLAUSE)               ;Name=0
  164.                 (GENSYM)               ;Tag=1
  165.                 (TRANSFORM-KEYWORDS :REPORT REPORT ;Keywords=2
  166.                             :INTERACTIVE INTERACTIVE)
  167.                 (CADR CLAUSE)               ;BVL=3
  168.                 FORMS)))               ;Body=4
  169.             CLAUSES)))
  170.       `(BLOCK ,BLOCK-TAG
  171.      (LET ((,TEMP-VAR NIL))
  172.        (TAGBODY
  173.          (RESTART-BIND
  174.            ,(MAPCAR #'(LAMBDA (DATUM)
  175.                 (LET ((NAME (NTH 0 DATUM))
  176.                   (TAG  (NTH 1 DATUM))
  177.                   (KEYS (NTH 2 DATUM)))
  178.                   `(,NAME #'(LAMBDA (&REST TEMP)
  179.                       #+LISPM (SETQ TEMP (COPY-LIST TEMP))
  180.                       (SETQ ,TEMP-VAR TEMP)
  181.                       (GO ,TAG))
  182.                 ,@KEYS)))
  183.             DATA)
  184.            (RETURN-FROM ,BLOCK-TAG ,EXPRESSION))
  185.          ,@(MAPCAN #'(LAMBDA (DATUM)
  186.                (LET ((TAG  (NTH 1 DATUM))
  187.                  (BVL  (NTH 3 DATUM))
  188.                  (BODY (NTH 4 DATUM)))
  189.                  (LIST TAG
  190.                    `(RETURN-FROM ,BLOCK-TAG
  191.                       (APPLY #'(LAMBDA ,BVL ,@BODY)
  192.                          ,TEMP-VAR)))))
  193.                DATA)))))))
  194.  
  195. (DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME FORMAT-STRING
  196.                          &REST FORMAT-ARGUMENTS)
  197.                    &BODY FORMS)
  198.   `(RESTART-CASE (PROGN ,@FORMS)
  199.      (,RESTART-NAME ()
  200.         :REPORT (LAMBDA (STREAM)
  201.           (FORMAT STREAM ,FORMAT-STRING ,@FORMAT-ARGUMENTS))
  202.       (VALUES NIL T))))
  203.  
  204. (DEFUN ABORT          ()      (INVOKE-RESTART 'ABORT)
  205.                          (ERROR 'ABORT-FAILURE))
  206. (DEFUN CONTINUE       ()      (INVOKE-RESTART 'CONTINUE))
  207. (DEFUN MUFFLE-WARNING ()      (INVOKE-RESTART 'MUFFLE-WARNING))
  208. (DEFUN STORE-VALUE    (VALUE) (INVOKE-RESTART 'STORE-VALUE VALUE))
  209. (DEFUN USE-VALUE      (VALUE) (INVOKE-RESTART 'USE-VALUE   VALUE))
  210.